;; introducing the namespace shen.primitives which consists of the KLambda macros
;; :only (*clojure-version* *in* *err* *out* fn) is used here, so no clojure macros or functions are used by accident
(ns shen.primitives
  (:refer-clojure 
                :only (*clojure-version* *in* *err* *out* fn))
  (:require 	[clojure.test :as test] 
				[clojure.set :as set]
                [clojure.java.io :as io] 
                [clojure.string :as string]
                [clojure.walk :as walk])
  (:use clojure.tools.trace)
  (:import [java.util.regex Pattern]))

;; alias for the clojure.core namespace, for better readability
(clojure.core/alias 'cl 'clojure.core)


;;; Assignments (2) --DONE--
;;; Symbols in Shen correspond to Vars in Clojure: they evaluate to themselves
;; The variables are created in a different namespace shen.vars
;; to solve the dual namespace problem in Shen

;; creating a namespace for the variables used (dual namespace behaviour)
(cl/create-ns 'shen.vars)

;; set assigns value y to the symbol x in the namespace shen.vars
(cl/defn set
	([x] (cl/partial set x))
  ([x y]
  (cl/let [x (cl/with-meta x {:dynamic true})]
    (cl/intern 'shen.vars x y)
    y)))

;; value receives the value of a given shen variable by searching the corresponding variable in the shen.vars namespace and resolving it.
(cl/defn value [x] 
        (cl/let [s# (cl/symbol (cl/str "shen.vars/" (cl/name x)))]
                                (if (cl/resolve s#)
                                        (cl/eval s#)
                                        (throw (Exception. (cl/str "variable " x " has no value."))))))


;; Globals needed for Shen
(set '*language* "Clojure")
(set '*implementation* (cl/str "Clojure " (cl/clojure-version)))
(set '*port* "1.0")
(set '*porters* "Dominik Greibl, Dominikus Herzberg")
(set '*version* "version 3.0")
(set '*stinput* cl/*in*)
(set '*maximum-print-sequence-size* 20)

;;; Boolean Operations (4) --DONE--
;; Here the arguments have to be checked to be true or false, since only these are accepted as booleans in Shen/KLambda
;; everything else works as in Clojure
;;checking if a expr is a boolean, e.g true or false (helpfunction, not part of KLambda)
(cl/defn  clj-boolean? [expr] (cl/or (cl/isa? expr true) (cl/isa? expr false)))
;; throwing an exception if the argument is not a boolean
(cl/defn  throwBool [x] (throw (Exception. (cl/str x " is not a boolean."))))


;; "and" and "or" implement the boolean check, if they are used as arguments and-fn and or-fn are used instead
(cl/defmacro and
  ([x] `(cl/let [x# ~x] (if (clj-boolean? x#) x# (throwBool x#))))
  ([x & next]
    `(cl/let [x# ~x]
             (if (clj-boolean? x#)
                (if x# (and ~@next) false)
                (throwBool x#)))))
                
(cl/defmacro or
        ([x] `(cl/let [x# ~x] (if (clj-boolean? x#) x# (throwBool x#))))
        ([x & next]
          `(cl/let [x# ~x]
                (if (clj-boolean? x#) 
                        (if x# true (or ~@next))
                        (throwBool x#)))))
						
(cl/defn ^:private and-fn
  ([x] (and x))
  ([x & y] (and x y)))

(cl/defn ^:private or-fn
  ([x] (or x))
  ([x y] (or x y)))						

;; kl_if is currently not used due to problems with the Invalid Method Code Length Exception
;; the if special form is used instead
(cl/defmacro kl_if 
       ([x] `(fn [y# z#] (shen.primitives/if '~x y# z#)))
       ([x y] `(fn [z#] (shen.primitives/if '~x (cl/eval '~y) z#)))
       ([x y z] `(cl/let [x# ~x] (if (clj-boolean? x#) (if x# ~y ~z) (throwBool x#)))))


; Shen/Kl: (cond (expr1 expr2) (expr3 expr4) ...)
; Clojure: (cond  expr1 expr2   expr3 expr4  ...)
; Normally cond should throw an exception if no condition is met. 
; This is not implemented yet due to the same reasons as with if.
(cl/defmacro cond [ & cases]
        `(cl/cond ~@(cl/apply cl/concat cases)))

;;; Symbols (2)
;; corresponds to symbol in Clojure
;; true and false are no symbols in Clojure.
;; / is replaced since it is a normal part of a Shen symbol.
(cl/defn intern [s]
        (cl/condp cl/= s
                  "true" true
                  "false" false
                  "/" (cl/symbol "/")
                  "/." 'lambda
                  (cl/symbol (string/replace s "/" "_slash_")))) ; returns var
  
;; function evaluates a symbol to the assigned function
(cl/defn function [x] 
        (cl/cond 
		  (cl/seq? x) (cl/eval x)
		  (cl/= x 'and) and-fn
		  (cl/= x 'or) or-fn
          (cl/symbol? x) (cl/eval x) 
          (cl/fn? x) x
          :else (throw (RuntimeException. (cl/str "undefined function " x)))))

;;; Strings (5) --DONE--
;; receives the nth unitstring of x
(cl/defn pos 
	([x] (cl/partial pos x))
	([x n] (cl/subs x n (cl/inc n))))
;; returns the parameter string without the first character
(cl/defn tlstr [x] (cl/subs x 1))

;; concatenates two strings
(cl/defn cn 
	([str1] (cl/partial cn str1))
	([str1 str2] (if (cl/string? str1)
					 (if (cl/string? str2)
						(cl/str str1 str2)
						(throw (Exception. (cl/str str2 " is not a String."))))
					 (throw (Exception. (cl/str str1 " is not a String."))))))

;; In Shen only atoms can be converted to strings, everything that is not a collection is an atom.
(cl/defn str [x]
  (if (cl/not (cl/coll? x)) 
	(if (cl/string? x)
		(cl/str "\"" x "\"")
        (cl/str x))
    (throw (Exception.
          (cl/str x " is not an atom; str cannot convert it to a string.")))))
;; checks if the argument is a string
(cl/defn string? [x] (cl/string? x))
;; takes an integer and returns the corresponding ascii character
(cl/defn n->string [x] (cl/str (cl/char x)))
(cl/defn byte->string [x] (cl/str (cl/char x)))
;; takes a string and returns the ascii value of its first character
(cl/defn string->n [x] (cl/int (cl/first x)))

                                

;;; Error Handling (3)
;; throws a simple exception
(cl/defn simple-error [s] (throw (RuntimeException. s)))

;; trap-error is similar to try in Clojure.
;; the first parameter is the form that possibly throws an exception.
;; the second parameter is a lambda function which receives the thrown exception as parameter.
(cl/defmacro trap-error 
	([x] `(fn [y#] (trap-error ~x y#)))
	([x y] `(try ~x (catch Exception e# (~y e#)))))

;; returns the message of an Exception/Throwable
(cl/defn error-to-string [e] 
        (if (cl/instance? Throwable e)
                (.getMessage e)
                (throw (IllegalArgumentException. (cl/str e " is not an exception.")))))


;;; Lists (4) --DONE--
;; checks if the argument is a list, but not the empty list
(cl/defn cons? [x] (cl/and (cl/coll? x) (cl/not (cl/empty? x))))

;; private function to check if the argument is a pair created by cons with a non-cons
(cl/defn ^:private pair? [x] 
	(cl/and (cl/vector? x) (cl/= (cl/count x) 2)))
  
;; adds the first argument to the second argument.
;; if the second argument is a list, the first argument is inserted at the beginning of the list
;; otherwise a list with the two arguments (called Pair in Shen) is created.
(cl/defn cons 
	([x] (cl/partial cons x))
	([x y]
       (if (cl/and (cl/coll? y) (cl/not (pair? y)))
			(cl/cons x y) [x y])))


;; hd gets the first element of a list
(cl/defn hd [x] (cl/first x))
;; tl gets the tail of a list or the second value of a pair
(cl/defn tl [x] (if (pair? x) (cl/second x) (cl/rest x)))

;;; Generic Functions
;; Defines Shen functions
;; see set, value, function
(cl/defmacro defun 
	([f] `(fn [params# & code#] (cl/apply #(defun ~f params# %) code#)))
	([f params] `(fn [ & code#] (cl/apply #(defun ~f ~params %) code#)))
	([f params & code] 
        (cl/let [f# (if (cl/seq? f) (cl/eval f) f)]
        `(do 
           (cl/defn ^:dynamic ~f#
                        ~@(cl/for [p# (cl/map #(cl/take % params) (cl/range 1 (cl/count params)))] 
                                `([~@p#] (cl/partial ~f# ~@p#)))
                        ([~@params] ~@code)) 
                '~f#))))

;; lambda is similar to fn in Clojure
;; lambda: (lambda X X)
;; fn: (fn [X] X)				
(cl/defmacro lambda 
	([x] `(fn [y#] (lambda ~x y#)))
	([x y] `(fn [~x] ~y)))

;; let is similar to let in Clojure but only one binding can be given
;; Shen: (let X Y Z)
;; Clojure: (let [X Y] Z)
(cl/defmacro let 
	([X] `(fn [Y# Z#] (let ~X Y# Z#)))
	([X Y] `(fn [Z#] (let ~X ~Y Z#)))
	([X Y Z]
	  (cl/let [X-safe (if (cl/seq? X) (cl/gensym (cl/eval X)) X)
             Z (walk/postwalk
                             #(if (cl/= X %) X-safe %) Z)]
            `(cl/let [~X-safe ~Y]
                     ~Z))))

;; = combines Clojures == with Clojure's =
;; for numbers automatically == is used
(cl/defn shen.primitives/= 
	([x] (cl/partial = x))
	([x y] 
             (if (cl/and (cl/number? x) (cl/number? y)) 
                        (cl/== x y) 
                        (cl/= x y))))

;; Freeze freezes the argument in its current state, it can be unfrozen with thaw						
(cl/defmacro freeze [z] `(cl/fn [] ~z)) ; see "Porting Shen"
;; type casts the first argument to the second argument
(cl/defn type 
	([x] (cl/partial type x))
	([x t] (cl/cast t x)))
;; see freeze	
(cl/defn thaw [x] (x))

;; From here on the functions are mainly copied from Hakan Rabergs code for
;; reasons stated in the short documentation
;; some minor modifications have been made to match the Code with the rest of the Code		  
(cl/defn ^:private interned? [X]
  (cl/and (cl/seq? X) (cl/= 'intern (cl/first X))))
		  
(cl/defn ^:private recur?
  ([path] (cl/partial recur? path))
  ([path fn]
     (cl/or (cl/= 'cond (cl/last (cl/drop-last path)))
         (set/superset? '#{defun cond if do let}
                        (cl/set path)))))

(cl/defn ^:private maybe-apply [kl path]
  (if (cl/= 'cond (cl/last path)) kl
      (cl/list 'function kl)))

		  
(cl/defn pre-eval-without-macros
  ([kl] (pre-eval-without-macros kl #{} [] :unknown))
  ([kl scope] (pre-eval-without-macros kl scope [] :no-recur))
  ([kl scope path fn]
     (cl/condp cl/some [kl]
       scope kl
       cl/symbol? (cl/condp cl/= (cl/name kl)
                 "true" true
                 "false" false
                 (cl/list 'quote kl))
       cl/seq? (cl/let [[fst snd trd & rst] kl
                       fn (if ('#{defun} fst) snd
                              fn)
                       scope (cl/condp cl/get fst
                               '#{defun} (cl/into scope trd)
                               '#{let lambda} (cl/conj scope snd)
                               scope)
                       fst (cl/condp cl/some [fst]
                             (cl/every-pred
                              #{fn}
                              (recur? path)) 'recur
                             (cl/some-fn
                              interned?
                              scope) (maybe-apply fst path)
                              cl/seq? (maybe-apply (pre-eval-without-macros fst scope) path)
                              (if (cl/= 'cond (cl/last path))
                                (pre-eval-without-macros fst scope)
                                fst))
                       path (cl/conj path fst)
                       snd (cl/condp cl/get fst
                             '#{defun let lambda} snd
                             '#{if} (pre-eval-without-macros snd scope)
                             (pre-eval-without-macros snd scope path fn))
                       trd (cl/condp cl/get fst
                             '#{defun} trd
                             '#{let} (pre-eval-without-macros trd scope)
                             (pre-eval-without-macros trd scope path fn))]
                      (cl/take-while (cl/complement cl/nil?)
                                  (cl/concat [fst snd trd]
                                          (cl/map #(pre-eval-without-macros % scope path fn) rst))))
       kl)))

(cl/defn ^:private define* [name body]
  (cl/let [kl ((function 'shen-shen->kl) name body)]
            (cl/binding [cl/*ns* (cl/the-ns 'shen)]
              ((function 'eval) kl)
              name)))

(cl/defn ^:private shen-elim-define [X]
  (if (cl/seq? X)
    (if ('#{define} (cl/first X)) (define* (cl/second X) (cl/nnext X))
        (cl/map shen-elim-define X))
    X))

(cl/defn ^:private cleanup-clj [clj]
  (cl/condp cl/some [clj]
    cl/vector? (recur (cl/list* clj))
    cl/coll? (if ('#{cl/deref} (cl/first clj))
            (cl/symbol (cl/str "@" (cl/second clj)))
            clj)
    cl/char? (cl/intern clj)
    clj))

(def ^:private missing-symbol-pattern #"Unable to resolve symbol: (.+) in this context")

(cl/defn ^:private missing-symbol [s]
  (cl/when-let [[_ sym] (cl/re-find missing-symbol-pattern (cl/or s ""))] sym))	

; (cl/defn ^:private def-missing-symbol [sym env]
                ; (if (cl/and
                      ; (cl/symbol? sym)
                      ; (cl/not (cl/or (cl/resolve sym)
                                     ; (cl/contains? env sym))))
                    ; (cl/eval `(def ~(cl/with-meta sym {:dynamic true}) '~sym)))
                ; sym) 

; (cl/defmacro def-missing-symbols [expr]
             ; `(walk/postwalk 
                ; #(def-missing-symbol % ~(cl/keys &env)) 
                ; '~expr))    
  
;; try-eval tries to evaluate the expr and interns the missing symbols
;; if macros could have been used for the evaluation the macro 
;; "def-missing-symbol" would have been working.
;; But since "env" is not available in functions local variables would have been overwritten as well
(cl/defn try-eval [expr]
	(try (cl/eval expr)
		(catch RuntimeException e
			(cl/if-let [s (missing-symbol (error-to-string e))]
				(cl/binding [cl/*ns* (cl/the-ns 'shen)]
					(cl/intern 'shen (cl/symbol s) (cl/symbol s))
					(try-eval expr))
				(throw e)))))

(cl/defn eval-shen* [body]
  (cl/let [body (walk/postwalk cleanup-clj body)]
            (cl/binding [cl/*ns* (cl/the-ns 'shen)]
              (cl/->> body
                   (cl/map (function 'eval))
                   cl/last))))

(cl/defmacro eval-shen [& body]
  `(eval-shen* '~body))	 
	 
(cl/doseq [[name args] '{defmacro [name] defprolog [name] prolog? [] package [name exceptions]}]
  (cl/eval
   `(cl/defmacro ~name [~@args & ~'body]
      `(eval-shen ~(cl/concat ['~name ~@args] ~'body)))))				
				
;; eval-without-macros evaluates the pre-evaluated form
(cl/defn eval-without-macros [expr]
         (cl/-> (cleanup-clj expr)
                shen-elim-define
                pre-eval-without-macros
                try-eval))
       
;;; Vectors (4) --DONE--
;; since vectors are mutable in Shen, we needed a way to do that.
;; Atoms where the appropriate choice here, since in contrast to transients, the output 
;; is still human readable. 
(def fail! 'fail!)
(cl/defn absvector [n] (cl/atom (cl/vec (cl/take n
                              (cl/repeat fail!)))))

;; sets a value in a vector							  
(cl/defn address-> 
	([v] (cl/partial address-> v))
	([v i] (cl/partial address-> v i))
	([v i val] (cl/atom (cl/swap! v cl/assoc i val))))
;; reads a value from a vector
(cl/defn shen.primitives/<-address 
	([vect] (cl/partial <-address vect))
	([vect n] (cl/nth (cl/deref vect) n)))

;; checks if the argument is a vector	
(cl/defn absvector? [x] (cl/= (cl/type x) clojure.lang.Atom))

;;; Streams (4)
;; for streams we used clojure.java.io functions.
(cl/defn pr 
	([v] (cl/partial pr v))
	([v s] 
        (cl/binding [*out* (if (cl/= (cl/type s) clojure.lang.LineNumberingPushbackReader) *out* s)]
                (cl/print v) 
                (cl/flush)
                v)))
(cl/defn read-byte [s] (.read s) )
(cl/defn open 
	([t] (cl/partial open t))
	([t p] (cl/partial open t p))
	([t p d]
        (if (cl/= t 'file) 
                (if (cl/= d 'in) 
                        (io/reader (cl/str (value '*home-directory*) p))
                        (if (cl/= d 'out) 
                                (io/writer (cl/str (value '*home-directory*) p))
                                (throw (Exception. (cl/str "invalid direction: " d)))))
                (throw (Exception. (cl/str "invalid stream type: " t))))))
(cl/defn close [s] (.close s))

;;; Time (1) --DONE--
;; Since "It is optional to set this function to record not real time, but run time" [Marc Tarver: Shen doc 3.0, 2011],
;; we chose to implement real, run and date as possible arguments
(def internal-start-time (System/currentTimeMillis))
(cl/defmacro get-time [ u ] 
             (cl/let [u (if (cl/seq? u) (cl/eval u) u)]
                     (if (cl/= u 'real) `(. java.lang.System currentTimeMillis)
                       (if (cl/= u 'date) `(.toString (new java.util.Date))
                         (if (cl/= u 'run)
                           `(cl/* 1.0 (clojure.core// (clojure.core/- (System/currentTimeMillis) internal-start-time) 1000))
                           `(throw (IllegalArgumentException. (cl/str "get-time does not understand the parameter " '~u))))))))
        
;;; Arithmetic (9) --DONE--
;; in the documentation it is not defined how many arguments the arithmetic functions are allowed to receive
;; for every arithmetic function 2 arguments are supplied
(cl/defn shen.primitives/+ ([x] (cl/partial cl/+' x))
                          ([x y] (cl/+' x y)))
(cl/defn shen.primitives/- ([x] (cl/partial cl/-' x))
                          ([x y] (cl/-' x y)))
(cl/defn shen.primitives/* ([x] (cl/partial cl/*' x))
                          ([x y] (cl/*' x y)))
(cl/defn /  ([x] (cl/partial clojure.core// x))
                        ([x y] (if (cl/== y 0) 
                                                (throw (ArithmeticException. "division by zero")) 
                                                (clojure.core// (cl/double x) (cl/double y)))))
(cl/defn shen.primitives/> 
	([x] (cl/partial > x))
	([x y]  (cl/> x y)))
(cl/defn shen.primitives/< 
	([x] (cl/partial < x))
	([x y]  (cl/< x y)))
(cl/defn shen.primitives/>= 
	([x] (cl/partial >= x))
	([x y] (cl/>= x y)))
(cl/defn shen.primitives/<= 
	([x] (cl/partial <= x))
	([x y] (cl/<= x y)))
;; checks if the argument is a number	
(cl/defn number? [x] (cl/number? x))